;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;Select-Rectangle.Lisp
;;
;;  copyright © 1987-89 Apple Computer
;;
;;
;;  This file has some examples of making trap calls and using window.
;;
;;  It implements a function for dragging out a gray rectangle.
;;  Then it shows how to use this function to create a new class of windows.
;;

(eval-when (eval compile)
  (require 'traps)
  (require 'records))

;;;;;;;;;;;;;;;;;;
;;
;;select-rectangle
;;
;;  returns a rectangle selected by the user.  If it is passed a rectangle,
;;  this rectangle holds the result.  If it isn't passed a rectangle, a new
;;  rectangle is allocated on the Mac Heap.
;;
(defobfun (select-rectangle *window*) (&optional rectangle)
  (declare (object-variable wptr))
  (let* ((anchor-point (window-mouse-position))
         (old-mouse (window-mouse-position))
         (new-mouse old-mouse)
         (r (or rectangle (make-record :rect))))
    (rset r rect.topleft old-mouse)
    (rset r rect.bottomright old-mouse)
    (rlet ((old-pen-state :penstate))
      (with-port wptr
        (_GetPenState :ptr old-pen-state)
        (_PenMode :word (position :patxor *pen-modes*))
        (rset wptr window.pnPat *gray-pattern*)
        (_FrameRect :ptr r)
        (loop
          (unless (mouse-down-p) (return))     ;return when the mouse lets up
          (unless (eq old-mouse new-mouse)
            (_FrameRect :ptr r)
            (_pt2rect :long anchor-point
                      :long new-mouse
                      :ptr r)
            (_FrameRect :ptr r)
            (sleep 1/60)
            (setq old-mouse new-mouse))
          (setq new-mouse (window-mouse-position)))
        (_FrameRect :ptr r)
        (_SetPenState :ptr old-pen-state)
        r))))


;;;;;;;;;;;;;;;;;;;;
;;
;; *rect-window*
;;
;;  a class of windows that lets you draw rectangle pictures

(defobject *mondrian-window* *window*)

(defobfun (window-click-event-handler *mondrian-window*) (where)
  (declare (ignore where))
    (rlet ((my-rect :rect))
      (select-rectangle my-rect)
      (_InverRect :ptr my-rect)))

(oneof *mondrian-window*
       :window-title "Click and Drag")
